home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0921.ZIP / LCOMMT.ARC / TTL.PAS < prev   
Pascal/Delphi Source File  |  1988-01-24  |  14KB  |  586 lines
  1. {$R-,S-,I+,D+,T-,F-,V+,B-,N-,L+ }
  2. {$M 16384,0,655360 }
  3. (*
  4. **  TTL is a complete, if somewhat limited, terminal emulation
  5. **  program  designed to demonstrate the use of the LiteComm
  6. **  ToolBox.  The executable version is included so that you can
  7. **  try it out while viewing the code.  To successfully create a
  8. **  new version of TTL, you must have the XMODEM engine
  9. **  which is provided as part of your registration package.
  10. **  While non-registered users cannot create a new version of TTL,
  11. **  you may still examine the TTL program, and use it as a basis for
  12. **  your own programming.
  13. **
  14. **  Information Technology, Ltd.
  15. *)
  16.  
  17. program TTL;
  18.  
  19. uses
  20.   DOS, LctKrnl, LctSupp, LtXMKrnl, LtXmodem, Crt;
  21.  
  22. const
  23.   CPort    : integer = 1;
  24.   Baud     : integer = 2400;
  25.   Parity   : char = 'N';
  26.   Databits : integer = 8;
  27.   Stopbits : integer = 1;
  28.   Yxmode   : boolean = false;
  29.   Halfd    : boolean = false;
  30.   Hostm    : boolean = false;
  31.   CPtr     : CCBPTR = NIL;
  32.   Imask    : byte = $00;
  33.  
  34. type
  35.   FnStr = string[64];
  36.  
  37. procedure GetFileName(var FName : FnStr);
  38.  
  39. begin
  40.   Writeln;
  41.   Write('Enter File Name: ');
  42.   FName := '';
  43.   Readln(FName);
  44. end;                                    { GetFileName }
  45.  
  46. procedure XSend;
  47. var
  48.   SFile     : file;
  49.   SFilename : FnStr;
  50.   Buffer    : array[1..1024] of byte;
  51.   BufNdx    : integer;
  52.   Result    : XMResult;
  53.   ToRead    : integer;
  54.   ToSend    : integer;
  55.   FRes      : integer;
  56.  
  57. begin
  58.   Writeln;
  59.   Writeln('Sending a File');
  60.   GetFileName(SFileName);
  61.   if Length(SFilename) = 0 then
  62.   begin
  63.     Writeln('Zero Length Name entered');
  64.     ReadLn;
  65.     exit;                                { nothing to send }
  66.   end;
  67.  
  68.   Assign(SFile, SFilename);
  69. {$I-}
  70.   Reset(SFile, 1);                     { attempt to open }
  71. {$I+}
  72.   FRes := IOResult;
  73.   if FRes <> 0 then
  74.   begin
  75.     Writeln('Error Opening file: ',FRes);
  76.     ReadLn;
  77.     exit;
  78.   end;
  79.  
  80.   if not CommSetup(CPort, Baud, 'N', 8, 1) then
  81.   begin
  82.     Writeln('Unable to change Port parameters, <RET> to continue');
  83.     Readln;
  84.     exit;
  85.   end;
  86.  
  87. {
  88.   Transmit the file using the engine
  89. }
  90.   if YModem then
  91.     ToRead := 1024
  92.   else
  93.     ToRead := 128;
  94.   Result := Success;
  95.   FRes := 1;
  96.   while (FRes > 0) and
  97.         (Result = Success) do
  98.   begin
  99.     FillChar(Buffer, Sizeof(Buffer), $00);
  100. {$I-}
  101.     BlockRead(SFile, Buffer, ToRead, FRes);
  102. {$I+}
  103.     BufNdx := 1;
  104.     if FRes = 0 then                   {EOF Signal ?}
  105.       FRes := -1;
  106.  
  107.     while (FRes > 0) and
  108.           (Result = Success) do
  109.     begin
  110.       if Yxmode then
  111.         if FRes <> ToRead then         { short block }
  112.         begin
  113.           ToRead := 128;               { sending short }
  114.           YModem := false;
  115.         end;;
  116.  
  117.       Result := LxmTrec(CPort, Buffer[BufNdx]);   { do actual transmission }
  118.  
  119.       case Result of
  120.         Success : begin
  121.                     Write('Sent Record: ', (RecNum - 1), ^M);
  122.                     Dec(FRes, ToRead);
  123.                     Inc(BufNdx, ToRead);
  124.                   end;
  125.         InitCan  : begin
  126.                      Writeln;
  127.                      Writeln('Cancel Req. INIT, <RET> to continue');
  128.                      Readln;
  129.                    end;
  130.         InitFail : begin
  131.                      Writeln;
  132.                      Writeln('Too many retries INIT, <RET> to continue');
  133.                      Readln;
  134.                    end;
  135.         CanReq  : begin
  136.                     Writeln;
  137.                     Writeln('Cancel Requested, <RET> to continue');
  138.                     Readln;
  139.                   end;
  140.         Retry   : begin
  141.                     Writeln;
  142.                     Writeln('Too Many Tries, Record: ', (RecNum - 1));
  143.                     Readln;
  144.                   end;
  145.         else
  146.           Writeln;
  147.           Writeln('Fatal Transmission Error, <RET> to continue');
  148.           Readln;
  149.       end;                             { case }
  150.     end;                               { inner while }
  151.     if Result = Success then
  152.       if FRes <> -1 then
  153.         FRes := 1;
  154.   end;                                 { outer while }
  155.  
  156.   if Result = Success then
  157.   begin
  158.     Result := LxmTeot(CPort);
  159.     if Result <> Success then
  160.     begin
  161.       Writeln('Error Ending Transmission');
  162.       Readln;
  163.     end;
  164.   end;
  165.  
  166.   if not CommSetup(CPort, Baud, Parity, Databits, Stopbits) then
  167.   begin
  168.     Writeln('Unable to Reset Port parameters, <RET> to continue');
  169.     Readln;
  170.   end;
  171. end;                                   { XSend }
  172.  
  173. procedure WxSend;
  174. begin
  175. end;                                   { WxSend }
  176.  
  177. procedure SendFile;
  178. begin
  179.   if Yxmode then
  180.   begin
  181.     YModem := true;
  182.     XSend;
  183.   end
  184.   else
  185.   begin
  186.     YModem := false;
  187.     XSend;
  188.   end;
  189. end;
  190.  
  191. procedure WxRecv;
  192. begin
  193. end;                                   { WxRecv }
  194.  
  195. procedure XRecv;
  196. var
  197.   RFile     : file;
  198.   RFilename : FnStr;
  199.   Buffer    : array[1..1024] of byte;    { allow for YModem }
  200.   Result    : XMResult;
  201.   HandShake : byte;
  202.   RecdSize  : integer;
  203.   FRes      : word;
  204.  
  205. begin
  206.   Writeln;
  207.   Writeln('Receiving a File');
  208.   GetFileName(RFileName);
  209.   if Length(RFilename) = 0 then
  210.   begin
  211.     Writeln('Zero Length Name entered');
  212.     ReadLn;
  213.     exit;                                { nothing to send }
  214.   end;
  215.  
  216.   Assign(RFile, RFilename);
  217. {$I-}
  218.   Rewrite(RFile, 1);                     { attempt to open }
  219. {$I+}
  220.   FRes := IOResult;
  221.   if FRes <> 0 then
  222.   begin
  223.     Writeln('Error Creating file: ',FRes);
  224.     ReadLn;
  225.     exit;
  226.   end;
  227.  
  228.   if not CommSetup(CPort, Baud, 'N', 8, 1) then
  229.   begin
  230.     Writeln('Unable to change Port parameters, <RET> to continue');
  231.     Readln;
  232.     exit;
  233.   end;
  234.  
  235. {
  236.   Transmit the file using the engine
  237. }
  238.   Result := Success;
  239.   HandShake := CRCREQ;                 { Spec Checksum Mode }
  240.  
  241.   while (Result = Success) or
  242.         (Result = DupBlk) do
  243.   begin
  244.     FillChar(Buffer, TBSIZE, $00);
  245.     Result := LxmRrec(CPort, Buffer, RecdSize, RTOUT, HandShake); { receive a block }
  246.  
  247.     case Result of
  248.       Success : begin
  249. {$I-}
  250.                   BlockWrite(RFile, Buffer, RecdSize, FRes);
  251. {$I+}
  252.                   Write('Received Record: ', (RecNum - 1), ^M);
  253.                 end;
  254.       DupBlk  : begin
  255.                   Writeln;
  256.                   Writeln('Duplicate Block, ignored');
  257.                 end;
  258.       SeqErr  : begin
  259.                   Writeln;
  260.                   Writeln('Block Seq Error');
  261.                   Readln;
  262.                 end;
  263.       InitCan  : begin
  264.                   Writeln;
  265.                   Writeln('Cancel Req. INIT, <RET> to continue');
  266.                   Readln;
  267.                 end;
  268.       InitFail : begin
  269.                   Writeln;
  270.                   Writeln('Too many retries INIT, <RET> to continue');
  271.                   Readln;
  272.                 end;
  273.       CanReq  : begin
  274.                   Writeln;
  275.                   Writeln('Cancel Requested, <RET> to continue');
  276.                   Readln;
  277.                 end;
  278.       Retry   : begin
  279.                   Writeln;
  280.                   Writeln('Too Many Tries, Record: ', (RecNum - 1));
  281.                   Readln;
  282.                 end;
  283.       EndFile : begin
  284.                   Writeln;
  285.                   Writeln('Normal End, <RET> to continue');
  286.                   Readln;
  287.                 end;
  288.       TimeOut : begin
  289.                   Writeln;
  290.                   Writeln('SOH Timeout, <RET> to continue');
  291.                   Readln;
  292.                 end;
  293.       else
  294.         Writeln;
  295.         Writeln('Fatal Transmission Error, <RET> to continue');
  296.         Readln;
  297.     end;
  298.   end;
  299.  
  300.   Close(RFile);
  301.  
  302.   if not CommSetup(CPort, Baud, Parity, Databits, Stopbits) then
  303.   begin
  304.     Writeln('Unable to Reset Port parameters, <RET> to continue');
  305.     Readln;
  306.   end;
  307. end;                                   { XRecv }
  308.  
  309. procedure ReceiveFile;
  310. begin
  311.     XRecv;
  312. end;
  313.  
  314. procedure ChgBaud(var NBaud : integer);
  315. var
  316.   SBaud : integer;
  317.  
  318. begin
  319.   SBaud := NBaud;
  320.   Writeln;
  321.   Write('Enter new Baud Rate: ');
  322. {$I-}
  323.   Readln(SBaud);
  324. {$I+}
  325.   case SBaud of
  326.      110,
  327.      300,
  328.      600,
  329.     1200,
  330.     2400,
  331.     4800,
  332.     9600,
  333.     19200: NBaud := SBaud;
  334.   else
  335.     Write('Invalid Baud Rate, <enter> to continue');
  336.     Readln;
  337.   end;
  338. end;                                   { ChgBaud }
  339.  
  340. procedure ChgParity(var NPar : char);
  341. var
  342.   SPar : char;
  343.  
  344. begin
  345.   SPar := NPar;
  346.   Writeln;
  347.   Write('Enter new Parity: ');
  348. {$I-}
  349.   Readln(SPar);
  350. {$I+}
  351.   SPar := UpCase(SPar);
  352.   case SPar of
  353.     'O',
  354.     'E',
  355.     'N',
  356.     'M',
  357.     'S': NPar := SPar;
  358.   else
  359.     Write('Invalid Parity, <enter> to continue');
  360.     Readln;
  361.   end;
  362.  
  363. end;                                   { ChgParity }
  364.  
  365. procedure ChgData(var NData : integer);
  366. var
  367.   SData : integer;
  368.  
  369. begin
  370.   SData := NData;
  371.   Writeln;
  372.   Write('Enter new Data Bits: ');
  373. {$I-}
  374.   Readln(SData);
  375. {$I+}
  376.   case SData of
  377.      5,
  378.      6,
  379.      7,
  380.      8: NData := SData;
  381.   else
  382.     Write('Invalid Data Bits, <enter> to continue');
  383.     Readln;
  384.   end;
  385. end;                                   { ChgData }
  386.  
  387. procedure ChgStop(var NStop : integer);
  388. var
  389.   SStop : integer;
  390.  
  391. begin
  392.   SStop := NStop;
  393.   Writeln;
  394.   Write('Enter new Stop Bits: ');
  395. {$I-}
  396.   Readln(SStop);
  397. {$I+}
  398.   case SStop of
  399.      1,
  400.      2: NStop := SStop;
  401.   else
  402.     Write('Invalid Stop Bits, <enter> to continue');
  403.     Readln;
  404.   end;
  405. end;                                   { ChgStop }
  406.  
  407. procedure ChgComm;
  408. var
  409.   Sel       : char;
  410.   NBaud     : integer;
  411.   NParity   : char;
  412.   NData     : integer;
  413.   NStop     : integer;
  414.  
  415. begin
  416.   NBaud := Baud;
  417.   NParity := Parity;
  418.   NData := Databits;
  419.   NStop := Stopbits;
  420.  
  421.   repeat
  422.     ClrScr;
  423.     Writeln('-- C H A N G E   C O M M   S E T U P --');
  424.     Writeln('    presently ',NBaud, ',', NParity, ',', NData, ',', NStop);
  425.     Writeln;
  426.     Writeln('B-  change Baud rate');
  427.     Writeln('P-  change Parity');
  428.     Writeln('D-  change Data bits');
  429.     Writeln('S-  change Stop bits');
  430.     Writeln;
  431.     Writeln('A-  Abandon changes');
  432.     Writeln('Q-  Quit and install changes');
  433.     Writeln;
  434.     Write('    Enter Selection -> ');
  435.  
  436.     Sel := ReadKey;
  437.     if Sel = #0 then
  438.       Sel := ReadKey;
  439.     Sel := UpCase(Sel);
  440.  
  441.     case Sel of
  442.       'B':  ChgBaud(NBaud);
  443.       'P':  ChgParity(NParity);
  444.       'D':  ChgData(NData);
  445.       'S':  ChgStop(NStop);
  446.       'Q':  if CommSetup(CPort, NBaud, Nparity, NData, NStop) then
  447.             begin
  448.               Baud := NBaud;
  449.               Parity := NParity;
  450.               Databits := NData;
  451.               Stopbits := NStop;
  452.             end;
  453.       else
  454.       end;
  455.   until (Sel = 'A') or (Sel = 'Q');
  456. end;                                   { ChgComm }
  457.  
  458. procedure Terminal;
  459. var
  460.   Ch    : byte;
  461.   DBool : boolean;
  462.  
  463. begin
  464.   ClrScr;
  465.   while true do
  466.   begin
  467.     if LctGet(CPort,Ch) then
  468.     begin
  469.       Write(char(Ch and $7f));
  470.       if Hostm then
  471.       begin
  472.         DBool := LctPut(CPort,Ch);
  473.         if Ch = $0d then
  474.         begin
  475.           Write(char($0a));
  476.           DBool := LctPut(CPort, $0a);
  477.         end;
  478.       end;
  479.     end;
  480.  
  481.     if KeyPressed then
  482.     begin
  483.       char(Ch) := ReadKey;
  484.       if Ch = $00 then
  485.         char(Ch) := ReadKey;
  486.       if Ch = $18 then
  487.         exit;
  488.       DBool := LctPut(CPort,Ch);
  489.       if not DBool then
  490.         writeln('Put Error');
  491.       if Hostm or Halfd then
  492.       begin
  493.         Write(char(Ch));
  494.         if Ch = $0d then
  495.         begin
  496.           Write(char($0a));
  497.           if Hostm then
  498.             DBool := LctPut(CPort, $0a);
  499.         end;
  500.       end;
  501.     end;
  502.   end;
  503. end;                                   { Terminal }
  504.  
  505. procedure MainMenu;
  506. var
  507.   Sel : char;
  508.  
  509. begin
  510.   repeat
  511.     ClrScr;
  512.     Writeln('-- M A I N   M E N U --');
  513.     Writeln;
  514.     Writeln('T-  enter Terminal mode');
  515.     Writeln('    CTRL-X exits terminal mode');
  516.     Write('H-  toggles Host mode (now ');
  517.     if Hostm then
  518.       Writeln('ON)')
  519.     else
  520.       Writeln('OFF)');
  521.     Write('G-  toGgles half-duplex mode (now ');
  522.     if Halfd then
  523.       Writeln('ON)')
  524.     else
  525.       Writeln('OFF)');
  526.     Writeln('C-  change Comm settings');
  527.     Writeln('    presently ',Baud, ',', Parity, ',', Databits, ',', Stopbits);
  528.     Write('X-  change Xmodem mode (now ');
  529.     if Yxmode then
  530.       Writeln('YMODEM)')
  531.     else
  532.       Writeln('NORMAL)');
  533.     Writeln('S-  Send a file');
  534.     Writeln('R-  Receive a file');
  535.     Writeln('Q-  Quit to DOS');
  536.     Writeln;
  537.     Write('    Select a Function -> ');
  538.  
  539.     Sel := ReadKey;
  540.     if Sel = #0 then
  541.       Sel := ReadKey;
  542. {
  543.   Dispatch Logic
  544. }
  545.     Sel := UpCase(Sel);
  546.  
  547.     case Sel of
  548.       'T':  Terminal;
  549.       'H':  begin
  550.               Hostm := not Hostm;
  551.               if Hostm then
  552.                 Halfd := false;
  553.             end;
  554.       'G':  begin
  555.               Halfd := not Halfd;
  556.               if Halfd then
  557.                 Hostm := false;
  558.             end;
  559.       'X':  Yxmode := not Yxmode;
  560.       'S':  SendFile;
  561.       'R':  ReceiveFile;
  562.       'C':  ChgComm;
  563.     else
  564.     end;
  565.   until Sel ='Q';
  566. end;                                   { MainMenu }
  567.  
  568. begin                                  { TTL }
  569.   CheckBreak := false;                 { disable ^C }
  570.  
  571.   if not CommOpen(CPort, Baud, Parity, Databits, Stopbits, 2000, 2000) then
  572.   begin
  573.     Writeln('Error opening Comm Port ',CPort);
  574.     Halt(1);
  575.   end;
  576.  
  577.   if SetModemSignals(Cport, (RTS or DTR)) then
  578.     MainMenu
  579.   else
  580.     Writeln('Unable to set modem signals');
  581.  
  582.   CommClose(CPort);
  583.  
  584.   ClrScr;
  585. end.
  586.